;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;hardcopy.lisp
;;
;;  copyright © 1987-89 Apple Computer
;;
;;
;;  this file defines a class of windows which know how to print their contents
;;
;;


;;  This file defines a new class of windows *hardcopy-window*.
;;  This class can be used as the superclass of any window classes which
;;  need to know how to print.
;;
;;  The basic operation of a hardcopy window is very simple.  The object
;;  function WINDOW-HARDCOPY is defined for the class.  When this function
;;  is called, it calls WINDOW-DRAW-CONTENTS, but sends the output to the
;;  current printer instead of to the screen.  You should define your
;;  WINDOW-DRAW-CONTENTS to print appropriately.

;;  This example does not handle multiple-page printout.  It could easily be
;;  extended to do so, using a variety of protocols.

;;  The following functions--used below--are not documented in the Pearl Lisp
;;  User's Guide.  These functions are equivalent to the Pascal functions
;;  described in Inside Macintosh:
;;
;;  %_PROPEN          %_PRCLOSE          %_PRINTDEFAULT
;;  %_PRVALIDATE      %_PRSTLDIALOG      %_PRJOBDIALOG
;;  %_PRJOBMERGE      %_PROPENDOC        %_PROPENPAGE
;;  %_PRCLOSEPAGE     %_PRCLOSEDOC       %_PRPICFILE
;;
;;  The function GET-PRINT-RECORD  returns a handle to a print record
;;  (described in Inside Macintosh).  This function can only be called
;;  after %_PROPEN has been called and before %_PRCLOSE has been called.
;;  The user can be given a chance to set up the print-record through
;;  the function PRINT-STYLE-DIALOG, which displays the standard page setup
;;  dialog.
;;


(eval-when (eval compile)
  (require 'traps)
  (require 'records)

  ;some constants for using the print manager
  (defconstant $PrintErr #x944)
  (defconstant $prJob.bJDocLoop (+ 62 6))
  (defconstant $iPrStatSize 26)
  (defconstant $bSpoolLoop 1)
  (defconstant $err-printer 94)
  (defconstant $err-printer-load 95)
  (defconstant $err-printer-start 97)
  )

(defun prchk (&optional (errnum $err-printer) 
                        &aux (print-error (%get-signed-word $PrintErr)))
   (unless (zerop print-error)
     ;%signal-error prints an error message based on an error number returned
     ;from the Macintosh print manager
     (%signal-error errnum print-error)))

(defobject *hardcopy-window* *window*)

(defobfun (window-hardcopy *hardcopy-window*) ()
  (unwind-protect
    (progn
      (%_PrOpen)
      (prchk $err-printer-load)
      (let ((pRec (get-print-record)))
        (when (%_PrJobDialog pRec)
          (let ((*hc-page-open-p* nil) (*inhibit-error* t) err)
            ;%_PrOpenDoc puts up a dialog window which causes the event system
            ;to get confused.  So we do the whole thing without interrupts, and
            ;make sure to clean up before handling errors.
            (declare (special *hc-page-open-p* *inhibit-error*))
            (setq err (catch :error
                        (without-interrupts
                         (with-port (%_PrOpenDoc pRec nil nil)
                           (unwind-protect
                             (progn
                               (prchk $err-printer-start)
                               (with-dereferenced-handles ((ppRec pRec))
                                 (let ((window-ptr wptr))
                                   (unwind-protect
                                     (progn
                                       (setq wptr (%getport))
                                       (without-interrupts
                                        (%_PrOpenPage (%getport) nil)
                                        (window-draw-contents)
                                        (%_PrClosePage (%getport))))
                                     (setq wptr window-ptr)))))
                             (%_PrCloseDoc (%getport))))
                         (when (eq (%get-byte (%get-ptr pRec) $prJob.bJDocLoop)
                                   $bSpoolLoop)
                           (prchk)
                           (%stack-block ((StRec $iPrStatSize))
                             (%_PrPicFile pRec nil nil nil StRec))
                           (prchk))
                         (setq *inhibit-error* nil))))
            (when *inhibit-error*
              (setq *inhibit-error* nil)
              (apply #'error err))
            t))))
    (%_PrClose)))


#|

(setq my-window (oneof *hardcopy-window*))

(defobfun (window-draw-contents my-window) ()
  (rlet ((r :rect :topleft #@(20 20)
                  :bottomright #@(100 100))
         (o :rect :topleft #@(100 100)
                  :bottomright #@(200 200)))
    (_FrameRect :ptr r)
    (_PaintOval :ptr o)))


|#